home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / MANAGER._c < prev    next >
Text File  |  1990-12-08  |  13KB  |  450 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "manager.h"
  22.  
  23. IMPORT ENV ENVTOP;
  24. IMPORT void ABORT(),ERROR(),SYSTEMERROR();      /* from linebufffer.c */
  25. IMPORT void ARGERROR(),ERROR();    /* from linebuff.c */
  26. FORWARD void reclaim_heap();
  27.  
  28.  
  29. /*
  30. EXPORT STRINGSTOP;
  31. EXPORT ATOMSTOP,ATOMHTOP;
  32. EXPORT setsize();  
  33. #if REALARITH
  34. EXPORT TERM mkreal(REAL);
  35. EXPORT REAL realval(TERM);
  36. #endif
  37. #if LONGARITH
  38. EXPORT TERM mklong(LONG);
  39. EXPORT LONG longval(TERM);
  40. #endif
  41. */
  42.  
  43.  
  44. /**********************************************************
  45. *                                                         *
  46. *  ATOMS                                                  *
  47. *                                                         *
  48. **********************************************************/
  49.  
  50. GLOBAL ATOM BASEATOM=atom_units(0);
  51. GLOBAL ATOM ATOMHTOP=LAST_ATOM;
  52. #ifdef DYNMEM
  53. GLOBAL ATOM ATOMSTOP;
  54. #else
  55. GLOBAL ATOM ATOMSTOP = MAXATOMS;
  56. #endif
  57.  
  58. /*   0         =>       +----------------------------+  */
  59. /*                      |  predefined atoms          |  */
  60. /*   LASTATOM  =>       + - - - - - - - - - - - - - -+  */
  61. /*                      |  global atoms in           |  */
  62. /*                      |  hashtable      |  |  |    |  */
  63. /*   ATOMHTOP  =>       |                 v  v  v    |  */
  64. /*                      |  - free - free - free -    |  */
  65. /*                      |                            |  */
  66. /*   ATOMSTOP  =>       |                 ^  ^  ^    |  */
  67. /*                      |  local          |  |  |    |  */
  68. /*                      |  atomstack      |  |  |    |  */
  69. /*   MAXATOMS  =>       +----------------------------+  */
  70.  
  71. /**********************************************************
  72. *                                                         *
  73. *  TERMS                                                  *
  74. *                                                         *
  75. **********************************************************/
  76.  
  77. #if !POINTEROFFSET
  78. GLOBAL TERM BASETERM=term_units(0);
  79. GLOBAL TERM GLOTOP=term_units(1);       
  80. GLOBAL TERM HEAPTOP=MAXTERMS;
  81. GLOBAL TERM LASTTERM=MAXTERMS;
  82. #endif
  83.  
  84. #if POINTEROFFSET
  85. #ifdef DYNMEM
  86. GLOBAL TERM BASETERM;
  87. GLOBAL TERM GLOTOP;       
  88. GLOBAL TERM HEAPTOP;
  89. GLOBAL TERM LASTTERM;
  90. #else
  91. GLOBAL TERM BASETERM= &TERMAREA[0];
  92. GLOBAL TERM GLOTOP= &TERMAREA[1];       
  93. GLOBAL TERM HEAPTOP= &TERMAREA[MAXTERMS];
  94. GLOBAL TERM LASTTERM= &TERMAREA[MAXTERMS];
  95. #endif
  96. #endif
  97.  
  98.                   /* increasing index of local variables */
  99.                   /*     |                               */
  100.                   /*     |                               */
  101.                   /*     V                               */
  102.                   /*                                     */
  103.                   /*     ^                               */
  104.                   /*     |                               */
  105.                   /*     |                               */
  106.                   /* decreasing index of heap nodes      */
  107.                
  108. /**********************************************************
  109. *                                                         *
  110. *  STRINGS                                                *
  111. *                                                         *
  112. **********************************************************/
  113.  
  114. GLOBAL STRING BASESTRING=0;
  115. GLOBAL STRING STRINGHTOP=1;
  116. #ifdef DYNMEM
  117. GLOBAL STRING STRINGSTOP;
  118. #else
  119. GLOBAL STRING STRINGSTOP=MAXSTRINGS;
  120. #endif
  121.  
  122. /* #if POINTEROFFSET
  123. GLOBAL STRING BASESTRING= &STRINGTAB[0];
  124. GLOBAL STRING STRINGHTOP= &STRINGTAB[1];
  125. GLOBAL STRING STRINGSTOP= &STRINGTAB[MAXSTRINGS];
  126. #endif
  127. */
  128.  
  129. /*   BASESTRING =>      +----------------------------+  */
  130. /*                      |  global strings            |  */
  131. /*                      |                 |  |  |    |  */
  132. /*   STRINGHTOP  =>     |                 v  v  v    |  */
  133. /*                      |  - free - free - free -    |   */
  134. /*                      |                            |  */
  135. /*   STRINGSTOP  =>     |                 ^  ^  ^    |  */
  136. /*                      |  local          |  |  |    |  */
  137. /*                      |  stringstack    |  |  |    |  */
  138. /*   MAXSTRINGS         +----------------------------+  */
  139.  
  140.  
  141.  
  142.  
  143. /**********************************************************
  144. *                                                         *
  145. *  ATOMS                                                  *
  146. *                                                         *
  147. **********************************************************/
  148.  
  149.  
  150. GLOBAL ATOM heapatom(void)
  151. {if(inc_atom(ATOMHTOP)>=ATOMSTOP) ABORT(ATOMSPACEE);
  152.  return (ATOM)ATOMHTOP ;
  153. }
  154.  
  155. GLOBAL ATOM stackatom(void)
  156. {if(dec_atom(ATOMSTOP)<=ATOMHTOP) ABORT(ATOMSPACEE);
  157.  nextatom(ATOMSTOP)=(card)STRINGSTOP;
  158.  return (ATOM)ATOMSTOP;
  159. }
  160.  
  161. #if ! INLINE
  162. GLOBAL boolean isheapatom(register ATOM A)
  163. {
  164.     return (A && A <=ATOMHTOP);
  165. }
  166. #endif
  167.  
  168. /**********************************************************
  169. *                                                         *
  170. *  TERMS                                                  *
  171. *                                                         *
  172. **********************************************************/
  173.  
  174. GLOBAL TERM arg1(register TERM T)
  175. { T=son(T); deref(T); return T; }
  176.  
  177. GLOBAL TERM arg2(register TERM T)
  178. { T=son(T)+term_units(1); /* T=br(T); */ deref(T); return T; }
  179.  
  180. GLOBAL TERM arg3(register TERM T)
  181. { T=son(T)+term_units(2); /* T=br(br(T)); */ deref(T); return T; }
  182.  
  183. GLOBAL TERM arg4(register TERM T)
  184. { T=son(T)+term_units(3); /* T=br(br(br(T))); */  deref(T); return T; }
  185.  
  186. GLOBAL TERM mkfunc(register ATOM N, register TERM T)
  187. { register TERM X;
  188.   X=GLOTOP; 
  189.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  190.   name(X)=N; son(X)=T;
  191.   return X;
  192. }
  193.  
  194. GLOBAL TERM mkatom(ATOM N)
  195. { register TERM X;
  196.   X=GLOTOP; 
  197.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  198.   name(X)=N; son(X)=nil_term;
  199.   return X;
  200. }
  201.  
  202. GLOBAL TERM mkint(int N)
  203. { register TERM X;
  204.   X=GLOTOP; 
  205.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  206.   name(X)=INTT; ival(X)=N;
  207.   return X;
  208. }
  209.  
  210. GLOBAL TERM mkfreevar(void)
  211. { register TERM X;
  212.   X=GLOTOP; 
  213.   if(inc_term(GLOTOP)>=HEAPTOP) reclaim_heap(true);
  214.   name(X)=UNBOUNDT; son(X)=nil_term;
  215.   return X;
  216. }
  217.  
  218. GLOBAL TERM stackterms(register int N)
  219. { register TERM X;
  220.   if(N==0) return nil_term;
  221.   X=GLOTOP;
  222.   GLOTOP+=term_units(N);
  223.   if(GLOTOP>=HEAPTOP) reclaim_heap(true);
  224.   return X;
  225. }
  226.  
  227. GLOBAL TERM mk2sons(ATOM NAM1, TERM SON1, ATOM NAM2, TERM SON2)
  228. { register TERM T,TT;
  229.     T=GLOTOP; TT=GLOTOP+term_units(1); GLOTOP+=term_units(2);
  230.     if(GLOTOP>=HEAPTOP) reclaim_heap(true);
  231.     name(T)=NAM1; son(T)=SON1; 
  232.     name(TT)=NAM2; son(TT)=SON2; 
  233.     return T;
  234. }
  235.  
  236. GLOBAL TERM freelist[MAXARITY+1];  /* chain of disposed nodes */ 
  237.  
  238. GLOBAL void InitMemory(void)
  239. { int N;
  240.   for (N=0;N<=MAXARITY;N++) freelist[N]=nil_term;
  241. }
  242.  
  243. GLOBAL TERM heapterms(register int N)
  244. { register TERM T;
  245.   if(N > MAXARITY) SYSTEMERROR("heapterms");
  246.   if( N==0) return nil_term;
  247.   if(non_nil_term(T=freelist[N])) 
  248.     { freelist[N]=son(T); return T; }
  249.   T=HEAPTOP-term_units(N);
  250.   if(GLOTOP>=T) 
  251.   {
  252.       reclaim_heap(false);
  253.       if(GLOTOP >= (T=HEAPTOP-term_units(N))) 
  254.       ABORT(LOCALSPACEE);
  255.   }
  256.   HEAPTOP=T;
  257.   inc_term(T);
  258.   return T;
  259. }
  260.  
  261. GLOBAL void freeterms(REGISTER int N, REGISTER TERM T)
  262. { register int I;
  263.   register TERM X;
  264.   if(N==0) return;
  265.   /* if(N > MAXARITY || T==nil_term) SYSTEMERROR("freeterms"); */
  266.   for(I=N,X=T;--I>=0;next_br(X))
  267.     if(name(X)>FUNCNAME) 
  268.       freeterms(arity(name(X)),son(X));
  269.   name(T)=VART; son(T)=freelist[N]; freelist[N]=T;
  270. }
  271.  
  272. void reclaim_heap(boolean abort)
  273. /* reclaim heapnodes if possible */
  274. {
  275.     register TERM T,LASTT;
  276.     register int i;
  277.  
  278.   start:
  279.     for(i=1;i<=MAXARITY;++i)
  280.     if(LASTT= (T=freelist[i]))
  281.     {   
  282.         if(T== (HEAPTOP+term_units(1)))
  283.         {
  284.         HEAPTOP +=term_units(i);
  285.         /* sum +=i; */
  286.         if(T==LASTT) freelist[i]=son(T);
  287.         else son(LASTT)=son(T);
  288.         goto start;
  289.         }
  290.         LASTT=T; T=son(T);
  291.     }
  292.     if(abort && HEAPTOP <=GLOTOP)
  293.     ABORT(LOCALSPACEE);
  294. }
  295.  
  296. /**********************************************************
  297. *                                                         *
  298. *  STRINGS                                                *
  299. *                                                         *
  300. **********************************************************/
  301.  
  302. GLOBAL STRING heapstring(register string s)
  303. { register STRING P;
  304.   STRING Q;
  305.   Q=P=STRINGHTOP;
  306.   while(repchar(P++)= *s++);
  307.   if(P >=STRINGSTOP) ABORT(aSTRINGSPACEE);
  308.   STRINGHTOP=P;
  309.   return Q;
  310. }
  311.  
  312. GLOBAL STRING stackstring(register string s)
  313. { register STRING P;
  314.   register string ss;
  315.   ss=s; P= --STRINGSTOP; while(*ss++) P--;
  316.   nextatom(ATOMSTOP)=(card)(STRINGSTOP=P);
  317.   if(STRINGHTOP>=STRINGSTOP)ABORT(aSTRINGSPACEE); 
  318.   while(repchar(P++)= *s++);
  319.   return STRINGSTOP;
  320. }
  321.  
  322. /**********************************************************
  323. *                                                         *
  324. *  NUMBERS                                                *
  325. *                                                         *
  326. **********************************************************/
  327.  
  328. #if REALARITH
  329. LOCAL union{ REAL r; int ir[REALSIZE]; } ri;
  330. #endif
  331. #if LONGARITH
  332. LOCAL union{ LONG l; int il[LONGSIZE]; } li;
  333. #endif
  334.  
  335. #if REALARITH
  336. GLOBAL TERM mkreal(REAL R)
  337. { register TERM T;
  338.   register int I;
  339.   TERM TT; 
  340.   ri.r=R; 
  341.   T=TT=stackterms(REALSIZE);
  342.   for(I=0;I<REALSIZE;I++)
  343.    { name(T)=INTT ; ival(T)=ri.ir[I];next_br(T);} 
  344.   return mkfunc(REALT,TT);
  345. }
  346.  
  347. GLOBAL REAL realval(register TERM T)
  348. { register int I;
  349.   if(name(T)!=REALT) ARGERROR();
  350.   T=son(T);
  351.   for(I=0; I<REALSIZE; I++)
  352.     { if(name(T)!=INTT) ARGERROR();
  353.       ri.ir[I]=ival(T); next_br(T);
  354.     }
  355.   return ri.r;
  356. }
  357. #endif
  358.  
  359. #if LONGARITH
  360. GLOBAL TERM mklong(LONG L)
  361. { TERM T,TT; int I;
  362.   li.l=L; 
  363.   TT=T=stackterms(LONGSIZE);
  364. #if !MSC
  365.   for(I=0; I<LONGSIZE; I++) 
  366.    { name(T)=INTT ; ival(T)=li.il[I];next_br(T);}
  367. #endif
  368. #if MSC
  369. #if LONGSIZE !=2
  370.    Please change the following lines
  371. #endif
  372.    name(T)=INTT ; ival(T)=li.il[0] ; next_br(T); 
  373.    name(T)=INTT ; ival(T)=li.il[1] ;
  374. #endif
  375.   return mkfunc(LONGT,TT);
  376. }
  377.  
  378. GLOBAL LONG longval(register TERM T)
  379. { register int I;
  380.   if(name(T)!=LONGT) ARGERROR();
  381.   T=son(T);
  382. #if !MSC
  383.   for(I=0; I<LONGSIZE; I++)
  384.     { if(name(T)!=INTT) ARGERROR();
  385.       li.il[I]=ival(T); next_br(T);
  386.     }
  387. #endif
  388. #if MSC
  389. #if LONGSIZE !=2
  390.    Please change the following lines
  391. #endif
  392.     if(name(T) !=INTT) ARGERROR();
  393.     li.il[0]=ival(T); next_br(T);
  394.     if(name(T) !=INTT) ARGERROR();
  395.     li.il[0]=ival(T);
  396. #endif
  397.   return li.l;
  398. }
  399. #endif
  400. /**********************************************************
  401. *                                                         *
  402. *  STATISTICS                                             *
  403. *                                                         *
  404. **********************************************************/
  405.  
  406. LOCAL int PERCENT;
  407.  
  408. LOCAL void wtotal(register string S, register int MAX)
  409. { ws(S); wi(MAX); PERCENT=MAX/100; }
  410.  
  411. LOCAL void wpercent(register string S, register int N)
  412. { ws(S); wi(N);
  413.   ws(" ("); wi(N/PERCENT);ws("%)"); 
  414. }
  415.  
  416. #define helpunit 1
  417.  
  418. /* evaluable predicate stats */
  419. GLOBAL void DOSTATS (void)
  420. { int RN; TERM T; 
  421.   int I;
  422.   extern TRAIL TRAILEND,BASETRAIL;
  423.   ws("\nProlog Execution Statistics:\n");
  424.   RN=0;
  425.   for(I=0;I<=MAXARITY;I++)
  426.    { T=freelist[I]; while(non_nil_term(T)) { RN+=I; T=son(T); } }
  427.  
  428.   wtotal("\nNodes: ",MAX_TERMS);
  429.   wpercent(" Stack: ",(int)(GLOTOP-BASETERM)-1);
  430.   wpercent(" Heap: ",MAX_TERMS-(int)(HEAPTOP-BASETERM));
  431.   wpercent(" Released: ",RN);
  432.  
  433.   wtotal("\nAtoms: ",MAX_ATOMS);
  434.   wpercent(" Stack: ",MAX_ATOMS-(int)(ATOMSTOP/atom_units(1))-1);
  435.   wpercent(" Heap: ",(int)(ATOMHTOP/atom_units(1)));
  436.  
  437.   wtotal("\nStrings: ",MAX_STRINGS); 
  438.   wpercent(" Stack: ",MAX_STRINGS-(int)(STRINGSTOP-BASESTRING)-1);
  439.   wpercent(" Heap: ",(int)(STRINGHTOP-BASESTRING));
  440.  
  441.   wtotal("\nEnvironments: ",MAX_ENVS);
  442.   wpercent(" Used: ",(int)( ENVTOP / helpunit )-1);
  443.  
  444.   wtotal("\nTrail: ",MAX_TRAILER);
  445.   wpercent(" Used: ",(TRAILEND-BASETRAIL)/sizeof(int));
  446.  
  447.   ws("\n");
  448. }
  449.  
  450.